home *** CD-ROM | disk | FTP | other *** search
/ Enter 2004 January / enter-2004-01.iso / files / maxima-5.9.0.exe / {app} / share / maxima / 5.9.0 / src / misc.lisp < prev    next >
Encoding:
Text File  |  2003-02-09  |  2.0 KB  |  44 lines
  1. ;;; -*-  Mode: Lisp; Package: Maxima; Syntax: Common-Lisp; Base: 10 -*- ;;;;
  2. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  3. ;;;     The data in this file contains enhancments.                    ;;;;;
  4. ;;;                                                                    ;;;;;
  5. ;;;  Copyright (c) 1984,1987 by William Schelter,University of Texas   ;;;;;
  6. ;;;     All rights reserved                                            ;;;;;
  7. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  8.  
  9. (in-package "MAXIMA")
  10. ;;  Maclisp compatibility package for the Lisp Machine -- run time
  11.  
  12. ;;  This function should really bash the array or use an invisible pointer
  13. ;;  to be compatible with maclisp.  ARRAY-SYMBOL can be either an array object
  14. ;;  or a symbol.  This only works for one dimensional arrays right now.
  15. ;;  IGNORE is normally the type, but Maclisp only has ART-Q arrays.
  16. ;;  *REARRAY of one arg is supposed to return the array.
  17. ;;  Rewrite at some point to use ADJUST-ARRAY-SIZE.
  18.  
  19. (DEFUN *REARRAY (ARRAY-SYMBOL &OPTIONAL IGN &REST DIMS) ign
  20.   (CHECK-ARG ARRAY-SYMBOL
  21.          (OR (SYMBOLP ARRAY-SYMBOL) (ARRAYP ARRAY-SYMBOL))
  22.          "a symbol or an array")
  23.   ;;All references to *rearray now are to symbols with the
  24.   ;; value cell being used for the array.
  25.   (macrolet ((symbol-array (x) `(symbol-value ,x)))
  26.   (COND ((NULL DIMS))
  27.     ((NULL (CDR DIMS))
  28.      (LET ((OLD-ARRAY (IF (SYMBOLP ARRAY-SYMBOL)
  29.                   (SYMBOL-ARRAY ARRAY-SYMBOL) ARRAY-SYMBOL))
  30.            (NEW-ARRAY (make-array (car dims)))
  31.            (MIN-ARRAY-LENGTH))
  32.        (SETQ MIN-ARRAY-LENGTH (MIN (ARRAY-DIMENSION-N 1 OLD-ARRAY)
  33.                        (ARRAY-DIMENSION-N 1 NEW-ARRAY)))
  34.        (DO ((I 0 (f1+ I))) ((= I MIN-ARRAY-LENGTH))
  35.            (ASET (AREF OLD-ARRAY I) NEW-ARRAY I))
  36.        (IF (SYMBOLP ARRAY-SYMBOL) (setf (symbol-array  ARRAY-SYMBOL)  NEW-ARRAY))
  37.        NEW-ARRAY))
  38.     (T (ERROR  "Can't handle *REARRAY with more than one dimension")))))
  39.  
  40. (DEFUN RUNTIME NIL (#-cl TIME
  41.             #+cl get-internal-run-time))
  42.  
  43.  
  44.